A very bitter chocolate problem.

A new kind of Nim.

Ryohei Miyadera
Daisuke Minematsu
Munetoshi Sakaguchi
Kwansei Gakuin University

Introduction.    Here we have a very interesting game .   We are going to introduce a new type of Nim .    By this problem we are going to introduce a new field in the research of Nim!
\(This\ research\ has\ been\ already\ introduced\ at\ MathPuzzle . com . \)

You can read this article without Mathematica, but we do a lot of calculation and made many graphs with Mathematica.  We print Mathematica code in blue.

Problem 1     Suppose that you have the following chocolate .   See Graph(1) .    The green parts are sweet, \(but\ the\ red\ part\ is\ very\ bitter . \ \ Two\ players\ in\ turn\ breaks\ the\ chocolate\ \((in\ a\ straight\ line\ along\ the\ grooves)\)\ and\ eats\ the\ piece\ he\ breaks\ off . \ \ The\ player\ to\ leave\ his\ opponent\ with\ the\ single\ bitter\ part\ is\ the\ winner . \ \ Describe\ the\ stratedy\ to\ ensure\ \(\(winning\)\(.\)\)\)

⋯⋯Graph (1)

Mathematica calculation for the above graphics.

Clear[ad, x, z, p, p2, p3, p4];
ad[x_] := {x[[1]], (Sqrt[3])*x[[2]]}; 
    p1[z_] := {Hue[0.3, 1, 1], 
        Polygon[Map[
            ad, {{2  z[[2]], -z[[1]] - 2}, {2  z[[2]] - 
                  1, -z[[1]] - 1}, {2  z[[2]] + 
                  1, -z[[1]] - 1}}]]}; 
    p2[z_] := {Hue[0.3, 1, 1], 
        Polygon[Map[
            ad, {{2  z[[2]], -z[[1]] + 0.1}, {2  z[[2]] - 
                  1, -z[[1]] - 1 + 0.1}, {2  z[[2]] + 
                  1, -z[[1]] - 1 + 
                  0.1}}]]};
p3[z_] := {Hue[1, 1, 1], 
          Polygon[Map[
              ad, {{2  z[[2]], -z[[1]] + 0.1}, {2  z[[2]] - 
                    1, -z[[1]] - 1 + 0.1}, {2  z[[2]] + 
                    1, -z[[1]] - 1 + 
                    0.1}}]]};
p4[z_] := {Hue[1, 0.1, 0.2], 
          Polygon[Map[
              ad, {{2  z[[2]], -z[[1]] + 0.1}, {2  z[[2]] - 
                    1, -z[[1]] - 1 + 0.1}, {2  z[[2]] + 
                    1, -z[[1]] - 1 + 0.1}}]]};

figurechoco2[x_] := 
      Block[{a, b, c, d, e, f}, a = 3 - x[[1]]; 
        b = -2 + 2  x[[2]]; c = 6 + 2  x[[3]]; 
        d = 4 + x[[4]]; e = -4 - 2  x[[5]]; 
        f = 4 - 2  x[[6]]; 
pointt1 = 
          Select[Flatten[
              Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 5}], 
              1], #[[1]] ≥ 
                  a && #[[2]]*2 - #[[1]] ≤ 
                  b && #[[2]]*2 + #[[1]] ≤ 
                  c && #[[1]] < d && #[[2]]*2 - #[[1]] > 
                  e && #[[2]]*2 + #[[1]] > 
                  f &]; 
pointt2 = 
          Select[Complement[
              Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 6}], 
                1], {{4, 1}}], #[[1]] > 
                  a && #[[2]]*2 - #[[1]] ≤ 
                  b && #[[2]]*2 + #[[1]] ≤ 
                  c && #[[1]] ≤ 
                  d && #[[2]]*2 - #[[1]] > 
                  e && #[[2]]*2 + #[[1]] > 
                  f &]; 
pointt3 = {{4, 
              1}}; 
pointt4 = 
          Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 6}], 1]; 
        Show[Graphics[
            Evaluate[
              Join[Map[p4, pointt4*1.1], Map[p3, pointt3*1.1], 
                Map[p2, pointt2*1.1], Map[p1, pointt1*1.1]]]], 
          AspectRatio -> Automatic, 
          Background -> Hue[1, 0.1, 0.2]]]

figurechoco2[{2, 1, 2, 1, 2, 1}]

Solution.  In this game there are two kinds of positions. One kind is a P-position, a previous-player-winning position.  The other is an N-position, a Next-player-winning position.  Let me explain about these positions.  In the followings we use the word option to mean "choice of move".

({{P - positions, N - Positions}, {Every option 
leads to an N - position, There is always 
at least one option 
leading to a P-position}})

By using computer we can find all the P-positions. (For this scale of problem you can find all the P-position only with pen and paper.) This Graph(2) contains all the P-positions.  All the other positions are N-position.  As you can see easily the original position in Graph(1) is an N-position, because you cannot find the original position in Graph(2).
  Therefore you are sure to win if you start the game as the first player.  The strategy is easy.  Let me explain how to use the strategy by an example.

⋯⋯Graph (2)

Mathematica code for finding the winning stratedy and get the above graph.

Clear[ss, al, allcases];
ss = 1; 
    al = Flatten[
        Table[{a, b, c, d, e, f}, {a, 0, ss + 2}, {b, 0, ss}, {c, 0, 
            ss + 2}, {d, 0, ss}, {e, 0, ss + 2}, {f, 0, ss}], 
        5];
allcases = 
        Select[al, #[[1]] + #[[3]] + 
                  1 ≥ #[[2]] && #[[2]] + #[[4]] ≥ #[[3]] && #[[3]] + #[[5]] + 
                  1 ≥ #[[4]] && #[[4]] + #[[6]] ≥ #[[5]] && #[[5]] + #[[1]] + 
                  1 ≥ #[[6]] && #[[6]] + #[[2]] ≥ #[[1]] &]; (*allcases are the set of all possible shapes of the chocolate .   Note that the above inequations are the necessary and sufficient condtions for {a, b, c, d, e, 
          f} to be a possible shape of the cholocate.*) 
num = 
        Length[allcases];
  
x1 = allcases[[num]];

(*x1 is the case with which we start the fame*) 
pos[x_List, y_List] := 
        Block[{s, t, u, v}, u = x; v = y; t = Apply[Plus, v]; 
          s = Position[v, t][[1, 1]]; 
u[[s]] = 
            u[[s]] - t; {Min[u[[6]] + u[[2]], u[[1]]], 
            Min[u[[1]] + u[[3]] + 1, 
              u[[2]]], 
Min[u[[2]] + u[[4]], 
              u[[3]]], 
Min[
              u[[3]] + u[[5]] + 1, 
              u[[4]]], 
Min[u[[4]] + u[[6]], 
              u[[5]]], 
Min[
              u[[5]] + u[[1]] + 1, 
              u[[6]]]}];
 (*pos[x, 
            y] returns the case that you will get after removing y from x
For example let x  =  {1, 2, 1, 2, 1, 
              2} and y  =  {1, 0, 0, 0, 0, 0},  
      then pos[x, 
          y] denotes the case you get after removing one from the 1  st coodinate of x;  
      that is {1, 1, 2, 1, 2, 1}*) 

    Clear[move, z, p, t1, t2, t3, t4, t5, t6];

    move[z_] := 
      Block[{p}, 
        p = z; 
Union[
          Table[pos[p, {t1, 0, 0, 0, 0, 0}], {t1, 1, 
              p[[1]]}], 
Table[
            pos[p, {0, t2, 0, 0, 0, 0}], {t2, 1, 
              p[[2]]}], 
Table[
            pos[p, {0, 0, t3, 0, 0, 0}], {t3, 1, 
              p[[3]]}], 
Table[
            pos[p, {0, 0, 0, t4, 0, 0}], {t4, 1, 
              p[[4]]}], 
Table[
            pos[p, {0, 0, 0, 0, t5, 0}], {t5, 1, 
              p[[5]]}], 
Table[
            pos[p, {0, 0, 0, 0, 0, t6}], {t6, 1, 
              p[[6]]}]
]
]

     (*move[
          x] returns all the cases you can get from x when you remove a part of x*)

Clear[se, t, n, allse, allfir, t, fir, 
        n];
se[
          0] = {{0, 0, 0, 0, 0, 0}};
t = 2; 
    n = 1; allse = {}; allfir = {}; 
    While[t < num, 
      fir[n] = Select[allcases, 
          Length[Intersection[move[#], se[n - 1]]] > 
              0 &]; 
se[n] = 
        Select[allcases, Complement[move[#], fir[n]] == {} &]; 
      allse = Union[allse, se[n]]; allfir = Union[allfir, fir[n]]; n = n + 1; 
      t = Length[allfir] + Length[allse]];
Print[t];Print[x1];

allse1 = 
      Map[#[[2]] &, Sort[Map[{Apply[Plus, #], #} &, allse]]]

Clear[ad, x, z, p1, p2, p3, p4];
ad[x_] := {x[[1]], (Sqrt[3])*x[[2]]}; 
    p1[z_] := {Hue[0.3, 1, 1], 
        Polygon[Map[
            ad, {{2  z[[2]], -z[[1]] - 2}, {2  z[[2]] - 
                  1, -z[[1]] - 1}, {2  z[[2]] + 
                  1, -z[[1]] - 1}}]]}; 
    p2[z_] := {Hue[0.3, 1, 1], 
        Polygon[Map[
            ad, {{2  z[[2]], -z[[1]] + 0.1}, {2  z[[2]] - 
                  1, -z[[1]] - 1 + 0.1}, {2  z[[2]] + 
                  1, -z[[1]] - 1 + 
                  0.1}}]]};
p3[z_] := {Hue[1, 1, 1], 
          Polygon[Map[
              ad, {{2  z[[2]], -z[[1]] + 0.1}, {2  z[[2]] - 
                    1, -z[[1]] - 1 + 0.1}, {2  z[[2]] + 
                    1, -z[[1]] - 1 + 
                    0.1}}]]};
p4[z_] := {Hue[1, 0.1, 0.2], 
          Polygon[Map[
              ad, {{2  z[[2]], -z[[1]] + 0.1}, {2  z[[2]] - 
                    1, -z[[1]] - 1 + 0.1}, {2  z[[2]] + 
                    1, -z[[1]] - 1 + 0.1}}]]};

Clear[x, p, q, a, b, c, d, e, f, n, m, s, t, pointt1, pointt2, 
        pointt3, pointt4];
sss = 6; 
    Do[Do[x = allse1[[4  p + q]]; a = 1 - x[[1]]; b = 2  x[[2]]; 
        c = 4 + 2  x[[3]]; d = 2 + x[[4]]; 
        e = -2 - 2  x[[5]]; 
        f = 2 - 2  x[[6]]; 
pointt1[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Select[Flatten[
                Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 2}], 
                1], #[[1]] ≥ 
                    a && #[[2]]*2 - #[[1]] ≤ 
                    b && #[[2]]*2 + #[[1]] ≤ 
                    c && #[[1]] < d && #[[2]]*2 - #[[1]] > 
                    e && #[[2]]*2 + #[[1]] > 
                    f &]]; 
pointt2[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Select[Complement[
                Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 3}], 
                  1], {{2, 1}}], #[[1]] > 
                    a && #[[2]]*2 - #[[1]] ≤ 
                    b && #[[2]]*2 + #[[1]] ≤ 
                    c && #[[1]] ≤ 
                    d && #[[2]]*2 - #[[1]] > 
                    e && #[[2]]*2 + #[[1]] > 
                    f &]]; 
pointt3[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, {{2, 
                1}}]; 
pointt4[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 3}], 
              1]], {q, 1, 4}], {p, 0, 4}]

Clear[p, q]; 
    Show[Graphics[
        Evaluate[
          Table[{Text[
                4  p + q, {2.4  sss*(q) + 2, 2  sss*(3 - p) - 35}], 
              Join[Map[p4, pointt4[4  p + q]*1.2], 
                Map[p3, pointt3[4  p + q]*1.2], 
                Map[p2, pointt2[4  p + q]*1.2], 
                Map[p1, pointt1[4  p + q]*1.2]]}, {q, 1, 4}, {p, 0, 4}]]], 
      AspectRatio -> Automatic, 
      Background -> Hue[1, 0.1, 0.2]]

An example of a stratedy.  From the original position you can move to the 18th, 19th or 20th positions in Graph (2).  Suppose that you chose the 18th position.  Then your opponent will choose one of the following 8 positions.

⋯⋯Graph (3)

Mathematica code for  the above graph.

move[{1, 1, 2, 1, 2, 1}]

move1 = {{0, 1, 2, 1, 2, 1}, {1, 0, 1, 1, 2, 1}, {1, 1, 0, 1, 2, 
            1}, {1, 1, 1, 0, 1, 1}, {1, 1, 1, 1, 2, 1}, {1, 1, 2, 1, 0, 
            1}, {1, 1, 2, 1, 1, 0}, {1, 1, 2, 1, 1, 1}};

Clear[x, p, q, a, b, c, d, e, f, n, m, s, t, pointt1, pointt2, 
        pointt3, pointt4];

sss = 6; 
    Do[Do[x = move1[[4  p + q]]; a = 1 - x[[1]]; b = 2  x[[2]]; 
        c = 4 + 2  x[[3]]; d = 2 + x[[4]]; 
        e = -2 - 2  x[[5]]; 
        f = 2 - 2  x[[6]]; 
pointt1[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Select[Flatten[
                Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 2}], 
                1], #[[1]] ≥ 
                    a && #[[2]]*2 - #[[1]] ≤ 
                    b && #[[2]]*2 + #[[1]] ≤ 
                    c && #[[1]] < d && #[[2]]*2 - #[[1]] > 
                    e && #[[2]]*2 + #[[1]] > 
                    f &]]; 
pointt2[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Select[Complement[
                Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 3}], 
                  1], {{2, 1}}], #[[1]] > 
                    a && #[[2]]*2 - #[[1]] ≤ 
                    b && #[[2]]*2 + #[[1]] ≤ 
                    c && #[[1]] ≤ 
                    d && #[[2]]*2 - #[[1]] > 
                    e && #[[2]]*2 + #[[1]] > 
                    f &]]; 
pointt3[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, {{2, 
                1}}]; 
pointt4[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 3}], 
              1]], {q, 1, 4}], {p, 0, 1}]

Clear[p, q]; 
    Show[Graphics[
        Evaluate[{{Hue[1, 1, 1], Rectangle[{12, 3}, {12, 4}]}, 
            Table[{Text[
                  4  p + q, {2.4  sss*(q) + 2, 2  sss*(3 - p) - 35}], 
                Join[Map[p4, pointt4[4  p + q]*1.2], 
                  Map[p3, pointt3[4  p + q]*1.2], 
                  Map[p2, pointt2[4  p + q]*1.2], 
                  Map[p1, pointt1[4  p + q]*1.2]]}, {q, 1, 4}, {p, 0, 1}]}]], 
      AspectRatio -> Automatic, 
      Background -> Hue[1, 0.1, 0.2]]

If the opponent chose the first option of Graph(3), then you can  choose the 7th of Graph(2).  Then your opponent choose one of the following 4 positions.
If the opponent choose the 1th or the 3rd position, you can take away the green part and win the game.
If the opponent choose the 2nd or 4th position of Graph (4), you can move to the 3rd of Graph(2).  After that the opponent will take the right or left green part, then you can take the remainning green part and win.
    The stratedy is clear.  If you start with the original position in Graph(1), then you have only to move to a P-position.  By the next move your opponent will move to N-position.  From this position you have only to a P-position.  By continuing this process you are sure to win.

⋯⋯Graph (4)

Mathematica code for  the above graph.

move[{0, 1, 1, 0, 1, 1}]

move2 = {{0, 0, 0, 0, 1, 1}, {0, 1, 0, 0, 1, 1}, {0, 1, 1, 0, 0, 
            0}, {0, 1, 1, 0, 0, 1}};

Clear[x, p, q, a, b, c, d, e, f, n, m, s, t, pointt1, pointt2, 
        pointt3, pointt4];

sss = 6; 
    Do[Do[x = move2[[4  p + q]]; a = 1 - x[[1]]; b = 2  x[[2]]; 
        c = 4 + 2  x[[3]]; d = 2 + x[[4]]; 
        e = -2 - 2  x[[5]]; 
        f = 2 - 2  x[[6]]; 
pointt1[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Select[Flatten[
                Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 2}], 
                1], #[[1]] ≥ 
                    a && #[[2]]*2 - #[[1]] ≤ 
                    b && #[[2]]*2 + #[[1]] ≤ 
                    c && #[[1]] < d && #[[2]]*2 - #[[1]] > 
                    e && #[[2]]*2 + #[[1]] > 
                    f &]]; 
pointt2[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Select[Complement[
                Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 3}], 
                  1], {{2, 1}}], #[[1]] > 
                    a && #[[2]]*2 - #[[1]] ≤ 
                    b && #[[2]]*2 + #[[1]] ≤ 
                    c && #[[1]] ≤ 
                    d && #[[2]]*2 - #[[1]] > 
                    e && #[[2]]*2 + #[[1]] > 
                    f &]]; 
pointt3[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, {{2, 
                1}}]; 
pointt4[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 3}], 
              1]], {q, 1, 4}], {p, 0, 0}]

Clear[p, q]; 
    Show[Graphics[
        Evaluate[{{Hue[1, 1, 1], Rectangle[{12, 3}, {12, 4}]}, 
            Table[{Text[
                  4  p + q, {2.4  sss*(q) + 2, 2  sss*(3 - p) - 35}], 
                Join[Map[p4, pointt4[4  p + q]*1.2], 
                  Map[p3, pointt3[4  p + q]*1.2], 
                  Map[p2, pointt2[4  p + q]*1.2], 
                  Map[p1, pointt1[4  p + q]*1.2]]}, {q, 1, 4}, {p, 0, 0}]}]], 
      AspectRatio -> Automatic, 
      Background -> Hue[1, 0.1, 0.2]]

Remark.  If you are going to play this game and want to memorize all the P-positions, it is better to make the list of P-positions smaller.  In Graph(2) the 2nd, 3rd and 4th positions are essentially the same, and the 6th and 8th positions are essentially the same, too.  By considering this we can choose 7 positions out of 20 positions in Graph(2), and we can make the following Graph(5).

⋯⋯Graph (5)

Mathematica program for above graph.

sss = 6; 
    Do[Do[x = allse1[[4  p + q]]; a = 1 - x[[1]]; b = 2  x[[2]]; 
        c = 4 + 2  x[[3]]; d = 2 + x[[4]]; 
        e = -2 - 2  x[[5]]; 
        f = 2 - 2  x[[6]]; 
pointt1[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Select[Flatten[
                Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 2}], 
                1], #[[1]] ≥ 
                    a && #[[2]]*2 - #[[1]] ≤ 
                    b && #[[2]]*2 + #[[1]] ≤ 
                    c && #[[1]] < d && #[[2]]*2 - #[[1]] > 
                    e && #[[2]]*2 + #[[1]] > 
                    f &]]; 
pointt2[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Select[Complement[
                Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 3}], 
                  1], {{2, 1}}], #[[1]] > 
                    a && #[[2]]*2 - #[[1]] ≤ 
                    b && #[[2]]*2 + #[[1]] ≤ 
                    c && #[[1]] ≤ 
                    d && #[[2]]*2 - #[[1]] > 
                    e && #[[2]]*2 + #[[1]] > 
                    f &]]; 
pointt3[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, {{2, 
                1}}]; 
pointt4[4  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 3}], 
              1]], {q, 1, 7}], {p, 0, 0}]

Clear[p, q]; 
    Show[Graphics[
        Evaluate[{{Hue[0, 0, 0], Rectangle[{12, 4}, {12, 4}]}, 
            Table[{Text[
                  4  p + q, {2.4  sss*(q) + 2, 2  sss*(3 - p) - 35}], 
                Join[Map[p4, pointt4[4  p + q]*1.2], 
                  Map[p3, pointt3[4  p + q]*1.2], 
                  Map[p2, pointt2[4  p + q]*1.2], 
                  Map[p1, pointt1[4  p + q]*1.2]]}, {q, 1, 7}, {p, 0, 0}]}]], 
      AspectRatio -> Automatic, 
      Background -> Hue[1, 0.1, 0.2]]

Problem 2    Suppose that you have the following chocolate .   See Graph (6) .   The rule is the same as in Problem 1.  Describe the stratedy to ensure winning.

⋯⋯Graph (6)

Mathematica code for the above graph.

Clear[ad, x, z, p, p2, p3, p4];
ad[x_] := {x[[1]], (Sqrt[3])*x[[2]]}; 
    p1[z_] := {Hue[0.3, 1, 1], 
        Polygon[Map[
            ad, {{2  z[[2]], -z[[1]] - 2}, {2  z[[2]] - 
                  1, -z[[1]] - 1}, {2  z[[2]] + 
                  1, -z[[1]] - 1}}]]}; 
    p2[z_] := {Hue[0.3, 1, 1], 
        Polygon[Map[
            ad, {{2  z[[2]], -z[[1]] + 0.1}, {2  z[[2]] - 
                  1, -z[[1]] - 1 + 0.1}, {2  z[[2]] + 
                  1, -z[[1]] - 1 + 
                  0.1}}]]};
p3[z_] := {Hue[1, 1, 1], 
          Polygon[Map[
              ad, {{2  z[[2]], -z[[1]] + 0.1}, {2  z[[2]] - 
                    1, -z[[1]] - 1 + 0.1}, {2  z[[2]] + 
                    1, -z[[1]] - 1 + 
                    0.1}}]]};
p4[z_] := {Hue[1, 0.1, 0.2], 
          Polygon[Map[
              ad, {{2  z[[2]], -z[[1]] + 0.1}, {2  z[[2]] - 
                    1, -z[[1]] - 1 + 0.1}, {2  z[[2]] + 
                    1, -z[[1]] - 1 + 0.1}}]]};

figurechoco2[x_] := 
      Block[{a, b, c, d, e, f}, a = 3 - x[[1]]; 
        b = -2 + 2  x[[2]]; c = 6 + 2  x[[3]]; 
        d = 4 + x[[4]]; e = -4 - 2  x[[5]]; 
        f = 4 - 2  x[[6]]; 
pointt1 = 
          Select[Flatten[
              Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 5}], 
              1], #[[1]] ≥ 
                  a && #[[2]]*2 - #[[1]] ≤ 
                  b && #[[2]]*2 + #[[1]] ≤ 
                  c && #[[1]] < d && #[[2]]*2 - #[[1]] > 
                  e && #[[2]]*2 + #[[1]] > 
                  f &]; 
pointt2 = 
          Select[Complement[
              Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 6}], 
                1], {{4, 1}}], #[[1]] > 
                  a && #[[2]]*2 - #[[1]] ≤ 
                  b && #[[2]]*2 + #[[1]] ≤ 
                  c && #[[1]] ≤ 
                  d && #[[2]]*2 - #[[1]] > 
                  e && #[[2]]*2 + #[[1]] > 
                  f &]; 
pointt3 = {{4, 
              1}}; 
pointt4 = 
          Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 6}], 1]; 
        Show[Graphics[
            Evaluate[
              Join[Map[p4, pointt4*1.1], Map[p3, pointt3*1.1], 
                Map[p2, pointt2*1.1], Map[p1, pointt1*1.1]]]], 
          AspectRatio -> Automatic, 
          Background -> Hue[1, 0.1, 0.2]]]

figurechoco2[{4, 2, 4, 2, 4, 2}]

How Mathematica imports these graphics.

Directory[]

SetDirectory["picture"]

FileNames["R*"]

Import["R123.gif"]

Show[%]

By using computer we can find all the P-positions.  (This time it will be very hard to find all the P-position only with pen and paper.) We have 118 P-positions. Instead of displaying all the P-positions we are going to choose a part of them.  We did the same thing when we made Graph (5).  This time we choose and  present 30 of all P-positions. The chosen P-positions are presented in Graph (7).
    As you can see easily, the original position in Graph (6) is an N-position, because you cannot find the original position in Graph (7).
  Therefore you are sure to win if you start the game as the first player.  The strategy is easy and you can use the same kind of stratedy you used in the previous problem.

⋯⋯Graph (7)

Program to made the list of all P-positions, and choose 30 of them.

Clear[ss, al, allcases];
ss = 2; 
    al = Flatten[
        Table[{a, b, c, d, e, f}, {a, 0, ss + 2}, {b, 0, ss}, {c, 0, 
            ss + 2}, {d, 0, ss}, {e, 0, ss + 2}, {f, 0, ss}], 
        5];
allcases = 
        Select[al, #[[1]] + #[[3]] + 
                  1 ≥ #[[2]] && #[[2]] + #[[4]] ≥ #[[3]] && #[[3]] + #[[5]] + 
                  1 ≥ #[[4]] && #[[4]] + #[[6]] ≥ #[[5]] && #[[5]] + #[[1]] + 
                  1 ≥ #[[6]] && #[[6]] + #[[2]] ≥ #[[1]] &]; (*allcases are the set of all possible shapes of the chocolate .   Note that the above inequations are the necessary and sufficient condtions for {a, b, c, d, e, 
          f} to be a possible shape of the cholocate.*) 

num = 
        Length[allcases];
  
x1 = 
        allcases[[num]];
  
pos[x_List, y_List] := 
        Block[{s, t, u, v}, u = x; v = y; t = Apply[Plus, v]; 
          s = Position[v, t][[1, 1]]; 
u[[s]] = 
            u[[s]] - t; {Min[u[[6]] + u[[2]], u[[1]]], 
            Min[u[[1]] + u[[3]] + 1, 
              u[[2]]], 
Min[u[[2]] + u[[4]], 
              u[[3]]], 
Min[
              u[[3]] + u[[5]] + 1, 
              u[[4]]], 
Min[u[[4]] + u[[6]], 
              u[[5]]], 
Min[
              u[[5]] + u[[1]] + 1, 
              u[[6]]]}];
  
move[z_] := 
      Block[{p}, 
        p = z; 
Union[
          Table[pos[p, {t1, 0, 0, 0, 0, 0}], {t1, 1, 
              p[[1]]}], 
Table[
            pos[p, {0, t2, 0, 0, 0, 0}], {t2, 1, 
              p[[2]]}], 
Table[
            pos[p, {0, 0, t3, 0, 0, 0}], {t3, 1, 
              p[[3]]}], 
Table[
            pos[p, {0, 0, 0, t4, 0, 0}], {t4, 1, 
              p[[4]]}], 
Table[
            pos[p, {0, 0, 0, 0, t5, 0}], {t5, 1, 
              p[[5]]}], 
Table[
            pos[p, {0, 0, 0, 0, 0, t6}], {t6, 1, 
              p[[6]]}]
]
]

Clear[se, t, n, allse, allfir, t, fir, 
        n];
se[0] = {{0, 0, 0, 0, 0, 0}};
t = 2; n = 1; allse = {}; allfir = {}; 
    While[t < num, 
      fir[n] = Select[allcases, 
          Length[Intersection[move[#], se[n - 1]]] > 
              0 &]; 
se[n] = 
        Select[allcases, Complement[move[#], fir[n]] == {} &]; 
      allse = Union[allse, se[n]]; allfir = Union[allfir, fir[n]]; n = n + 1; 
      t = Length[allfir] + Length[allse]];
Print[t]; Print[x1];
Which[MemberQ[allse, x1], Print["second"], MemberQ[allfir, x1], 
        Print["first"],  , 
        Print["undecided"]];
ws[x_] := Intersection[move[x], allse][[1]];

Length[allse]

selectdata = {}; data = allse; num = Length[data]; 
    While[num > 1, x = data[[1]]; selectdata = Append[selectdata, x]; 
      t = {x, RotateRight[x, 2], 
          RotateRight[x, 4], {x[[1]], x[[6]], x[[5]], x[[4]], 
            x[[3]], x[[2]]}, {x[[5]], x[[4]], x[[3]], 
            x[[2]], x[[1]], x[[6]]}, {x[[3]], x[[2]], 
            x[[1]], x[[6]], x[[5]], x[[4]]}}; 
      data = Complement[data, t]; num = Length[data]]; selectdata

selectdata = {{0, 0, 0, 0, 0, 0}, {0, 0, 0, 1, 0, 1}, {0, 0, 1, 1, 1, 
            1}, {0, 0, 1, 1, 2, 2}, {0, 0, 1, 2, 1, 2}, {0, 0, 1, 2, 2, 
            1}, {0, 0, 2, 2, 3, 1}, {0, 1, 0, 1, 1, 1}, {0, 1, 0, 1, 2, 
            2}, {0, 1, 0, 2, 1, 2}, {0, 1, 1, 0, 1, 1}, {0, 1, 1, 2, 2, 
            2}, {0, 1, 2, 1, 1, 2}, {0, 2, 1, 0, 1, 2}, {0, 2, 2, 0, 2, 
            2}, {1, 0, 1, 1, 1, 2}, {1, 0, 2, 2, 2, 2}, {1, 1, 1, 1, 1, 
            1}, {1, 1, 1, 1, 2, 2}, {1, 1, 1, 2, 3, 2}, {1, 1, 2, 1, 2, 
            1}, {1, 1, 2, 2, 4, 2}, {1, 2, 1, 2, 1, 2}, {1, 2, 2, 1, 2, 
            2}, {1, 2, 3, 1, 3, 2}, {2, 1, 2, 1, 2, 2}, {2, 1, 3, 2, 3, 
            1}, {2, 2, 2, 2, 2, 2}, {2, 2, 3, 2, 3, 2}, {2, 2, 4, 2, 4, 
            2}};

selectdata1 = 
      Map[#[[2]] &, 
        Sort[Map[{Apply[Plus, #], #} &, selectdata]]]

(*The list selectdata1 is the list of selected P - 
        positions ordered by the size of sum of numbers.*)

Clear[ad, x, z, p, p2, p3, p4];
ad[x_] := {x[[1]], (Sqrt[3])*x[[2]]}; 
    p1[z_] := {Hue[0.3, 1, 1], 
        Polygon[Map[
            ad, {{2  z[[2]], -z[[1]] - 2}, {2  z[[2]] - 
                  1, -z[[1]] - 1}, {2  z[[2]] + 
                  1, -z[[1]] - 1}}]]}; 
    p2[z_] := {Hue[0.3, 1, 1], 
        Polygon[Map[
            ad, {{2  z[[2]], -z[[1]] + 0.1}, {2  z[[2]] - 
                  1, -z[[1]] - 1 + 0.1}, {2  z[[2]] + 
                  1, -z[[1]] - 1 + 
                  0.1}}]]};
p3[z_] := {Hue[1, 1, 1], 
          Polygon[Map[
              ad, {{2  z[[2]], -z[[1]] + 0.1}, {2  z[[2]] - 
                    1, -z[[1]] - 1 + 0.1}, {2  z[[2]] + 
                    1, -z[[1]] - 1 + 
                    0.1}}]]};
p4[z_] := {Hue[1, 0.1, 0.2], 
          Polygon[Map[
              ad, {{2  z[[2]], -z[[1]] + 0.1}, {2  z[[2]] - 
                    1, -z[[1]] - 1 + 0.1}, {2  z[[2]] + 
                    1, -z[[1]] - 1 + 0.1}}]]};

Clear[x, p, q, a, b, c, d, e, f, n, m, s, t, pointt1, pointt2, pointt3, 
      pointt4]; sss = 12; 
    Do[Do[x = selectdata1[[5  p + q]]; a = 3 - x[[1]]; 
        b = -2 + 2  x[[2]]; c = 6 + 2  x[[3]]; 
        d = 4 + x[[4]]; e = -4 - 2  x[[5]]; 
        f = 4 - 2  x[[6]]; 
pointt1[5  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Select[Flatten[
                Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 5}], 
                1], #[[1]] ≥ 
                    a && #[[2]]*2 - #[[1]] ≤ 
                    b && #[[2]]*2 + #[[1]] ≤ 
                    c && #[[1]] < d && #[[2]]*2 - #[[1]] > 
                    e && #[[2]]*2 + #[[1]] > 
                    f &]]; 
pointt2[5  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Select[Complement[
                Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 6}], 
                  1], {{4, 1}}], #[[1]] > 
                    a && #[[2]]*2 - #[[1]] ≤ 
                    b && #[[2]]*2 + #[[1]] ≤ 
                    c && #[[1]] ≤ 
                    d && #[[2]]*2 - #[[1]] > 
                    e && #[[2]]*2 + #[[1]] > 
                    f &]]; 
pointt3[5  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, {{4, 
                1}}]; 
pointt4[5  p + q] = 
          Map[{#[[1]] + sss*p, #[[2]] + sss*q} &, 
            Flatten[Table[Table[{n, 1 - n/2 + m}, {m, 0, n}], {n, 0, 6}], 
              1]], {q, 1, 5}], {p, 0, 5}]

Clear[p, q]; 
    Show[Graphics[
        Evaluate[
          Table[{Text[
                5  p + q, {2.4  sss*(q) + 2, 2  sss*(3 - p) - 70}], 
              Join[Map[p4, pointt4[5  p + q]*1.2], 
                Map[p3, pointt3[5  p + q]*1.2], 
                Map[p2, pointt2[5  p + q]*1.2], 
                Map[p1, pointt1[5  p + q]*1.2]]}, {q, 1, 5}, {p, 0, 5}]]], 
      AspectRatio -> Automatic, 
      Background -> Hue[1, 0.1, 0.2]]

Mathematical background.  The theory of Nim is very rich in its contents.  There are also many disguises for the game of Nim.  For example the poisoned chocolate problem is one of them.  Robin [4] introduced this problem in the Mathematical Gazette.  We are going to explain about his problem and compare it to our problem.  The solution of this game is the same as that of the traditional Nim, and the solution of traditional Nim was given by C.Bouton [1].
    We are going to solve the poisoned chocolate problem that was by A.C.Robin [4].  We are going to change the numbers of parts.

Example 1.   This time you have the following chocolate.  See Graph(8). The rules are the same as in problme 1 and 2.  Describe the stratedy to ensure winning.

Solution.   We are going to use the method made by C.Bouton [1].  This chocolate has 6 rows over the red part, 4 columns on the right side, 2 rows under the red parts and 3 columns on the left side of the red part.  We partitioned these numbers 6,4,2,3 into powers of two.  Therefore 6 = 2 + 4, 4 = 4, 2 = 2 and 3 = 1 + 2.  Thus we can make Table(1).

⋯⋯Graph (8)

({{ orientation, over, right, under, left}, {numbers, 6, 4, 2, 3}, {1, 0, 0, 0, 1}, {2, 1, 0, 1, 1}, {4, 1, 1, 0, 0}})

⋯⋯Table (1)

We are going to check the table for each power of 2.  For (2^0)= 1 we have only 1 occurrence.  For (2^1)= 2 we have 3 occurrences, and for (2^2)= 4 we have 2 occurrences.
C.Bouton [1] proved that we have a P-position when each power of 2 occurs evenly often.  Therefore we  have an N-position in Graph (8).  We have to remove one row over the red part if you want to move to a P-position.  See Table (2).  Here each power of 2 occurs evenly often.

({{ orientation, over, right, under, left}, {numbers, 5, 4, 2, 3}, {1, 1, 0, 0, 1}, {2, 0, 0, 1, 1}, {4, 1, 1, 0, 0}})

⋯⋯Table (2)

Another option is to remove 3 columns from the left side of the red part.

Theorem. In the game of above chocolate problem we have a P-position when each power of 2 occurs evenly often.
We omit the proof, because this is a well known fact about the game of Nim.

Now we are going to compare Problem 1,2 and Example 1.  Example 1 is a typical example of traditional Nim.  We can represent the game with 4-numbers {(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3]),(Subscript[x, 4])}.  When it is your turn to move, you choose one of the 4 coodinates and take a number that is smaller than the coodinate from it.  These 4 coodinates are independent, i.e., you can take a number from one coodinate without affecting other coodinate.
    Problem 1 and 2 are different.  You can cut the chocolate in 6 ways, so it is appropriate to represent it with 6 numbers {(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3]),(Subscript[x, 4]),(Subscript[x, 5]),(Subscript[x, 6])}.  We represent the position in Graph(1) with {2,1,2,1,2,1} and the 6th position in Graph(2) with {0,1,0,1,1,1}.
    In Problem 1 and 2 these 6 coodinates are not independent.  We have 6 inequalities between these 6 coodinates.
    (Subscript[x, 1]) ≤ (Subscript[x, 2])+ (Subscript[x, 6]), (Subscript[x, 2]) ≤ (Subscript[x, 1])+ (Subscript[x, 3])+1, (Subscript[x, 3]) ≤ (Subscript[x, 2])+ (Subscript[x, 4]) , (Subscript[x, 4]) ≤ (Subscript[x, 3])+ (Subscript[x, 5])+1, (Subscript[x, 5]) ≤ (Subscript[x, 4])+ (Subscript[x, 6]), (Subscript[x, 6]) ≤ (Subscript[x, 5])+ (Subscript[x, 1])
    As far as we know there have been no research on the Nim conditioned by inequalities.  Therefore we are studying a very new kind of Nim.  In this article we only used computer programming to find a winning stratedy, because we could find a mathematical solutions for our problems.
    We have been studying more simple type of Nim conditioned by inequalities, and have managed to find a mathematical solutions.  We talked about it at Gama Amusement Society 2005 in Japan, and now writing a paper for a math journal.

References.
Charles Bouton [1] Nim, a game with a complete mathematical theory.  Ann of math.,Princeton,3. 1901-2.
E.Berlekamp, J. Conway and R. Guy [2] Winning ways.  Academic Press.1985
Richard Guy[3]  Fair game .   COMAP,Inc. 
A.C.Robin [4] A poisoned chocolate problem, Problem corner The Mathematical Gazette Volume 73 1989.
R.Miyadera [5] A Bitter Chocolate Problem, MathPuzzle.com